home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 001 / tmodem23.arc / MUSIC.INC < prev    next >
Encoding:
Text File  |  1985-05-17  |  13.6 KB  |  308 lines
  1. (****************************************************************************)
  2. (*                       INITIALIZE MUSIC VARIABLES                         *)
  3. (****************************************************************************)
  4.    procedure
  5.       initialize_music;
  6.    var
  7.       j,k    : integer;
  8.    begin
  9.  
  10.       { Frequencies for Octave 4. }
  11.       scale[  0 ]  := 1661.220;  { A }
  12.       scale[  1 ]  := 1760.000;
  13.       scale[  2 ]  := 1864.640;
  14.       scale[  3 ]  := 1864.640;  { B }
  15.       scale[  4 ]  := 1975.540;
  16.       scale[  5 ]  := 1975.540;
  17.       scale[  6 ]  :=  987.770;  { C }
  18.       scale[  7 ]  := 1046.500;
  19.       scale[  8 ]  := 1108.740;
  20.       scale[  9 ]  := 1108.740;  { D }
  21.       scale[ 10 ]  := 1174.700;
  22.       scale[ 11 ]  := 1244.500;
  23.       scale[ 12 ]  := 1244.500;  { E }
  24.       scale[ 13 ]  := 1318.500;
  25.       scale[ 14 ]  := 1318.500;
  26.       scale[ 15 ]  := 1318.500;  { F }
  27.       scale[ 16 ]  := 1396.900;
  28.       scale[ 17 ]  := 1479.980;
  29.       scale[ 18 ]  := 1479.980;  { G }
  30.       scale[ 19 ]  := 1568.000;
  31.       scale[ 20 ]  := 1661.224;
  32.  
  33.       factor[ 0 ] := 0.0625;
  34.       factor[ 1 ] := 0.1250;
  35.       factor[ 2 ] := 0.2500;
  36.       factor[ 3 ] := 0.5000;
  37.       factor[ 4 ] := 1.0000;
  38.       factor[ 5 ] := 2.0000;
  39.       factor[ 6 ] := 4.0000;
  40.  
  41.       notes[ 49 ] := 1047;
  42.       notes[ 50 ] := 1109;
  43.       notes[ 51 ] := 1175;
  44.       notes[ 52 ] := 1245;
  45.       notes[ 53 ] := 1319;
  46.       notes[ 54 ] := 1397;
  47.       notes[ 55 ] := 1480;
  48.       notes[ 56 ] := 1568;
  49.       notes[ 57 ] := 1661;
  50.       notes[ 58 ] := 1760;
  51.       notes[ 59 ] := 1865;
  52.       notes[ 60 ] := 1976;
  53.       k := 48;
  54.       while k > 0 do begin
  55.          notes[ k ] := notes[ k+12 ] div 2;
  56.          k := k - 1;
  57.       end;
  58.       k := 61;
  59.       while k < 85 do begin
  60.          notes[ k ] := notes[ k-12 ] * 2;
  61.          k := k + 1;
  62.       end;
  63.  
  64.       dnote[ 0 ]  := 1.0;
  65.       dnote[ 1 ]  := 1.5;
  66.       dnote[ 2 ]  := 1.75;
  67.       dnote[ 3 ]  := 1.875;
  68.       dnote[ 4 ]  := 1.9375;
  69.       dnote[ 5 ]  := 1.96875;
  70.       dnote[ 6 ]  := 1.984375;
  71.  
  72.       tempo        := 120.0;
  73.       music_mode   := 0.875;
  74.       rest_mode    := 0.125;
  75.       octave       := 4;
  76.       note_length  := 4;
  77.       tune_number  := round(random * 5.0);
  78.    end;
  79.  
  80.    procedure
  81.       play_note( note,length,dcnt : integer );
  82.    var
  83.       dur                : real;
  84.    begin
  85.       dur  := 240.0 / tempo * a_second / length * dnote[dcnt] - 3.0;
  86.       if note > 100 then
  87.          sound( notes[ note - 100 ] )
  88.       else
  89.          if note <= 20 then
  90.             sound( round( scale[ note ] * factor[ octave ] ) )
  91.          else
  92.             nosound;
  93.       delay( round(dur * music_mode) );
  94.       if rest_mode > 0.09 then begin
  95.          nosound;
  96.          delay( round(dur * rest_mode) );
  97.       end;
  98.    end;
  99.  
  100.    function
  101.       mval( s : strtype; var i : integer ) : integer;
  102.    var
  103.       v  : integer;
  104.    begin
  105.       v:=0;
  106.       i:=i+1;
  107.       while s[i] in [ '0'..'9' ] do begin
  108.          v:= ( v * 10 ) + ord(s[i]) - ord('0');
  109.          i:=i+1;
  110.       end;
  111.       mval:=v;
  112.    end;
  113.  
  114.    procedure
  115.       play( ms : strtype );
  116.    var
  117.       i   : integer;
  118.       l   : integer;
  119.       n   : integer;
  120.    begin
  121.       if silent_mode then exit;
  122.       i := 1;
  123.       while i < length( ms ) do begin
  124.          if ms[i] in [ 'A'..'G','P' ] then begin
  125.             n := ( ( ord(ms[i]) - ord('A') ) * 3 ) + 1;
  126.             case ms[i+1] of
  127.                '#','+' : begin
  128.                             i:=i+1;
  129.                             n:=n+1;
  130.                          end;
  131.                '-'     : begin
  132.                             i:=i+1;
  133.                             n:=n-1;
  134.                          end;
  135.             end;
  136.             l:=mval( ms,i );
  137.             if l=0 then l:=note_length;
  138.             dots:=0;
  139.             while ms[i]='.' do begin
  140.                i:=i+1;
  141.                dots:=dots+1;
  142.             end;
  143.             play_note(n,l,dots);
  144.          end
  145.          else begin
  146.             case ms[i] of
  147.                'T' : begin
  148.                         tempo:=mval( ms,i );
  149.                         if tempo<32  then tempo:=32;
  150.                         if tempo>255 then tempo:=255;
  151.                      end;
  152.                'O' : begin
  153.                         octave:=mval( ms,i );
  154.                         if octave>6 then octave:=6;
  155.                      end;
  156.                '>' : begin
  157.                         if octave < 6 then octave := octave + 1;
  158.                         i:=i+1;
  159.                      end;
  160.                '<' : begin
  161.                         if octave > 0 then octave := octave - 1;
  162.                         i:=i+1;
  163.                      end;
  164.                'L' : begin
  165.                         note_length:=mval( ms,i );
  166.                         if note_length=0 then note_length:=4;
  167.                      end;
  168.                'N' : begin
  169.                         n:=mval( ms,i )+100;
  170.                         if n>184 then n:=184;
  171.                         dots:=0;
  172.                         while ms[i]='.' do begin
  173.                            i:=i+1;
  174.                            dots:=dots+1;
  175.                         end;
  176.                         play_note(n,note_length,dots);
  177.                      end;
  178.                'M' : begin
  179.                         i:=i+1;
  180.                         case ms[i] of
  181.                            'N' : begin
  182.                                     music_mode := 0.875;
  183.                                     rest_mode  := 0.125;
  184.                                  end;
  185.                            'L' : begin
  186.                                     music_mode := 1.0;
  187.                                     rest_mode  := 0.0;
  188.                                  end;
  189.                            'S' : begin
  190.                                     music_mode := 0.75;
  191.                                     rest_mode  := 0.25;
  192.                                  end;
  193.                         end;
  194.                         i:=i+1;
  195.                      end;
  196.             else
  197.                i:=i+1;
  198.             end;
  199.          end;
  200.       end;
  201.       nosound;
  202.    end;
  203.  
  204. procedure
  205.  music_box;
  206. begin
  207.  case tune_number of
  208.   0 : begin
  209.    play('L16T155O2MNB4P8MSBBMNB4P8MSBBB8G#8E8G#8B8G#8B8O3E8O2B8G#8E8G#8B8G#8B8O3E8O2MNB4P8MSBBMNB4 ');
  210.    play('P8MSBBMNB4P8MSBBMNB4P8MSBBB8BBB8B8B8BBB8B8B8BBB8B8B8BBB8B8MLB2B2B8P8P4P4P8MSO1BBB8BBB8BBO2E8F#8G#8O1BB ');
  211.    play('B8BBO2E8G#G#F#8D#8O1B8BBB8BBB8BBO2E8F#8G#8EG#MLB4BMSAG#F#E8G#8E8O3BBB8BBB8BBO4E8F#8 ');
  212.    play('G#8O3BBB8BBO4E8G#G#F#8D#8O3B8BBB8BBB8BBO4E8F#8G#8MLEG#B4BAG#F#MSE8G#8E8O3G#G#G#8G#G#G#8G#G# ');
  213.    play('G#8O4C#8O3G#8O4C#8O3G#8O4C#8O3G#8F#8E8D#8C#8G#G#G#8G#G#G#8G#G#G#8O4C#8O3G#8O4C#8O3G#8O4C#8 ');
  214.    play('O3B8A#8B8A#8B8G#G#G#8G#G#G#8G#G#G#8O4C#8O3G#8O4C#8O3G#8O4C#8O3G#8F#8 ');
  215.    play('E8D#8C#8G#G#G#8G#G#G#8G#G#G#8O4C#8O3G#8O4C#8O3G#8O4C#8O3B8A#8B8O2BBB8F#F#F#8F#F#F#8G#8A8F#4MNA8MSG#8MNE4 ');
  216.    play('MSG#8F#8F#8F#8O3F#F#F#8F#F#F#8G#8A8MNF#4MSA8G#8MNE4MSG#8F#8O2BBB8O1BBB8BBB8BBO2MNE8F#8G#8O1BB ');
  217.    play('B8BBO2E8G#G#F#8D#8O1B8BBB8BBB8BBO2E8F#8G#8EG#MLB4MNBAG#F#E8G#8E8O3BBB8BBB8BBO4E8F#8 ');
  218.    play('G#8O3BBB8BBO4E8G#G#F#8D#8O3B8BBB8BBB8BBO4E8F#8G#8MLEG#MLB4MNBAG#F#MNE8G#8E8 ');
  219.    play('O3MLE56F56G56A56B56O4C56D56MNE8EEE8E8G#4.F#8E8D#8E8C#8MSO3BO4C#O3BO4C#O3B ');
  220.    play('O4C#D#EO3ABABABO4C#D#O3G#AG#AG#ABO4C#O3F#G#F#G#F#G#F#G#F#G#F#D#O2BO3MLBO4C#D#E8D#8E8 ');
  221.    play('C#8O3MSBO4C#O3BO4C#O3BO4C#D#EO3ABABABO4C#D#O3G#AG#AG#ABO4C#O3F#G#F#G#F#AF#EMNE8P8MLC#4 ');
  222.    play('MNC#O2CMSO3C#O2CO3D#C#O2BAAG#EC#C#C#C#C#ED#O1CG#G#G#G#G#G#O2C#EG#O3C#C#C#C#C#O2CO3C#O2CO3D# ');
  223.    play('C#O2BAAG#EC#C#C#C#C#ED#O1CG#G#G#G#G#MNG#O2C#EG#O3MSC#ED#C#D#O2CG#G#G#O3G#EC#D#O2CG#G#G# ');
  224.    play('O3G#EC#D#O2BG#G#A#GD#D#G#GG#GG#AG#F#EO1BA#BO2EO1BO2F#O1BO2G#ED#EG#EAF#BO3G#F#ED# ');
  225.    play('F#EC#O2BO3C#O2BO3C#D#EF#G#O2ABABO3C#D#EF#O2G#AG#ACO3C#D#EO2F#G#F#G#F#G#F#G#F#G#F#D#O1B ');
  226.    play('CO2C#D#EO1BA#BO2EO1BO2F#O1BO2G#ED#EG#EAF#BO3G#F#ED#F#EC#O2BO3C#O2BO3C#D#EF#G#O2ABABO3C# ');
  227.    play('D#EF#O2G#AG#ABO3C#D#EO2F#O3C#O2CO3C#D#C#O2AF#MNEO3MLEF#G#ABO4C#D#MNE8MSEEE8E8G#4. ');
  228.    play('MSF8MSE8D#8E8C#8O3BO4C#O3BO4C#O3BO4C#D#EO3ABABABO4C#D#O3G#AG#AG#ABO4C#O3F#G#F#G#F# ');
  229.    play('G#F#G#F#G#F#D#O2BO3MLBO4C#D#MNE8EEE8E8G#4.MSF#8E8D#8E8C#8O3BO4C#O3BO4C#O3B ');
  230.    play('O4C#D#EO3ABABABO4C#D#O3G#AG#AG#ABO4C#O3F#G#F#G#F#AG#F#E8O2B8O3E8G#G#G#8MNG#G#G#8 ');
  231.    play('G#G#G#8O4C#8O3G#8O4C#8O3G#8O4C#8O3G#8F#8E8D#8C#8G#G#G#8G#G#G#8G#G#G#8O4C#8O3G#8 ');
  232.    play('O4C#8O3G#8O4C#8O3B8A#8B8A#8B8G#G#G#8G#G#G#8G#G#G#8O4C#8O3G#8O4C#8O3G#8O4C#8O3G#8 ');
  233.    play('F#8E8D#8C#8G#G#G#8G#G#G#8G#G#G#8O4C#8O3G#8O4C#8O3G#8O4C#8O3B8A#8B8A#8B8 ');
  234.    play('O2F#F#F#8F#F#F#8G#8A8F#4A8G#8E4G#8F#8O0B8O1B8O2F#F#F#8F#F#F#8G#8A8F#4A8G#8E4G#8F#8 ');
  235.    play('BBB8O1BBB8BBB8BBO2E8F#8G#8O1BBB8BBO2E8G#G#F#8D#8O1B8BBB8BBB8BBO2E8F#8G#8EG#MLB4MNB ');
  236.    play('AG#F#E8O1B8O2E8O3BBB8BBB8BBO4E8F#8G#8O3BBB8BBO4E8G#G#F#8D#8O3B8BBB8BBB8BBO4E8F#8G#8O3EG#MLB4 ');
  237.    play('MNBAG#F#MLEF#G#MNAMLG#ABO4MNC#MLO3BO4C#D#MNEMLD#EF#MNG#AO3BO4AO3BO4AO3BO4AO3BO4AO3BO4AO3BO4AO3BO4AO3BMLE ');
  238.    play('F#G#MNAMLG#ABMNO4C#MLO3BO4C#D#MNEMLD#EF#MNG#AO3BO4AO3BO4AO3BO4AO3BO4AO3BO4AO3BO4AO3BO4AO3BP16 ');
  239.    play('MLG#O4G#O3MNG#P16MLD#O4D#O3MND#P16MLEO4EO3MNEP16MLAO4AO3MNAP16MLG#O4G#O3MNG#P16MLD#O4D#O3MND#P16MLEO4EO3MNEP16 ');
  240.   end;
  241.   1 : begin
  242.    play('L32T70O1E-CE-GO2CE-DCO1BGBO2DGFE-DE-CE-GO3CE-DCDCO2BAGFE-DE-CE-GO3C ');
  243.    play('O2E-DCO2BBBO3DGFE-FE-O3CE-GO4CE-DCDCO3BAGFE-DE-CO2GE-CO4CO3GE-A-O1FA-O2CFA-O3CE-DO2B-FDO1B- ');
  244.    play('O3B-FDGO1E-GB-O2E-GB-O3DCO2AG#AO3CO2AGAO3E-CO2GAO3E-CO2GAO3DCO2F#A ');
  245.    play('O3ACO2F#AO3F#CO2DAO3CO2AF#DB-O0GB-O1DGB-AGF#DF#AO2DCO1B-AB-GB-O2DGB-AGAGF#EDCO1B-AB-A-B-O2DGB-AGF#DF# ');
  246.    play('L32T70O2 AO3DCO2B-A-B-GB-O3DGB-AGAGF#AO2DCO1B-AB-GB-O3D ');
  247.    play('L32T70O2 GDO2B-GP32O3GDO2BGBO3DGP32O2GO3G ');
  248.    play('L32T70 O2GP32O2GO3GO2GO2B-GO3GO2GO2DGO3GO2G ');
  249.    play('L32T70 O3E-CE-GO4CO3GE-CP32O4CO2GECEGO4C ');
  250.    play('L32T70 P32O3CO4CO3CO2AO3CO4CO3CO2GO3CB-CP32O3CB-CAO0 ');
  251.    play('L32T70O2 FA-O1CFA-GFECEGO2CO1B-A-GFGFAO2CFAGFGFEDCO1B-A-GA-FA-C ');
  252.    play('L32T70O2 FA-GFECEGO3CO2B-A-GA-FA-CO3FA-GFGFEDC ');
  253.    play('L32T70O2 B-A-GA-O3FCO2A-FO3CO2A-FCA-FCO1A-O2FCO1A-O0L16D-.P32 ');
  254.    play('L32T70 O3A-FEFGFEFO0L16C.P32L32O2AFEFGF ');
  255.    play('L32T70O2 EFO0L16B-.P32L32O4DO3FGA-GFE-D ');
  256.    play('L32T70 O3E-GO4DO3GB-A-GFEL16O0E-P16L32O3E-.L64E-DE-DC ');
  257.    play('L32T70O2 DO2E-GO3GO2GO0CO2GO3GO2GO0B-O2GO3FO2GO0DO2GO3FO2GB-G ');
  258.    play('L32T70 O3EO2GP32O2GO3EO2GL64FAL32O3E-O5CO3E-L64O3FAL32O3E-O5C ');
  259.    play('L32T70 O3E-O1A-O2FO3DO2FO1A-O2FO3DO2FL64E-GL32O3D-O4B- ');
  260.    play('L32T70 O0F#O2E-O3CO2E-P32O2E-O3CO2E-P32E- ');
  261.    play('L32T70 O3CO2E-O0F#O3CO4CO3CO0F#O3CO4CO3CO0GO3CE-G ');
  262.    play('L32T70 O4CO3GE-CGE-CO2GO3FDO2BFE-O1CE-GO2CE-DCO1BGBO2DGFE-DE-CE-GO3CE-D ');
  263.    play('L32T70O2 CDCO2BAGFE-DE-CE-GO3CE-DCO2BGBO3DGFE-DE-CE- ');
  264.    play('L32T70O2 GO4CE-DO3BO4C ');
  265.   end;
  266.   2 : begin
  267.    play('T120O3L32P32B-O4CDCO3L16B-O4FDB-FDL32FE-DE-L16FO3B-O4DO3FA-GL32E-FGFL16E-B-GO4E-O3B-GL32B-A-GA- ');
  268.    play('L16B-E-GCE-O2AL32O3CDE-DL16CAFO4CO3AO4E-L32O3FGAGL16FO4CO3AO4FCD4P4P16L32GFE-FL16GC8P8P16 ');
  269.    play('L32FE-DE-F16O3B-8P8P16E-DCDE-16O3A16O4CO3B-AB-O4C16O3F8P8O4F8O3F8A8O4C8F4P4 ');
  270.    play('P8O3F8B-8O4D8F4P4P8O3G8B-8O4C8E4P4P16O3FGAGL16FO4CO3AO4FCAL32E-DCD ');
  271.    play('L16E-O3AO4CO3F+AL8B-O4DO3B-GA-O4FO3AFG16L32CDE-DL16CGE-O4CO3GO4DL32 ');
  272.    play('O3A-GFGL16A-DFO2BO3GE-8P8P16L32CDE-DC16O4C8.O3B-16A-16FGA-GF16O4F8.E-16D16O3B-O4CDCO3B-16 ');
  273.    play('O4B-8.A-16G16B-A-GA-B-16E-16GFE-FG16C16E-DCDE-16O3A16O4CDE-DC16F16O3A-GFGA-16G16B- ');
  274.    play('O4CDCO3B-16O4E-16O3GFE-FG16F16AB-O4CO3B-A16O4D16O3FE-DE-F16E-16GAB-AG16O4C16O3E-DCDE-16D16 ');
  275.    play('P8.P16B-O4CDCO3B-16L16O4FDB-FDL32FE-DE-L16FO3B-O4E-O3B-O4E-O3GL32E-FGFL16E-B-GO4E-O3B-G ');
  276.    play('L32B-A-GA-B-16E-8O4E-8E-16E-DCDE-16O3E-8O4E-8E-16CDE-DC16F16DCO3B-O4CD16L16O3FB-O4CO3A-B-2P2 ');
  277.   end;
  278.   3 : begin
  279.    play('T175O2G+8A8O3C8E-4D8D-8C8O2G+8A8O3C8E-4D8D-8C8O2G+8A8O3C8E-8O2G+8A8O3C8E-8O2G+8A8O3C8 ');
  280.    play('E-4D8D-8C8O2C+8D8F8A-4G8G-8F8C+8D8F8A-4G8G-8F8G+8A8O3C8E-4D8D-8C8O2G+8A8O3C8 ');
  281.    play('E-4D8D-8C8O2D+8E8G8B-4A8A-8A8C+8D8F8A-4G8G-8F8G+8A8O3C8P8F3F4F8F3C8O2F3P4 ');
  282.    play('O2G+8A8O3C8O2G+8A8O3C8O2G+8A8O3C8O2G+8A8O3C8O2G+8A8O3C8O2G+8A8O3C8O2G+8A8O3C8O2G+8A8O3C8 ');
  283.    play('O2G+8A8O3C8O2G+8A8O3C8O2G+8A8O3C8O2G+8A8O3C8O2G+8A8O3C8O2G+8A8O3C8O2G+8A8O3C8O2G+8A8O3C8 ');
  284.    play('C+8D8F8C+8D8F8C+8D8F8C+8D8F8C+8D8F8C+8D8F8C+8D8F8C+8D8F8O2G+8A8O3C8O2G+8A8O3C8O2G+8A8O3C8O2G+8A8O3C8 ');
  285.    play('O2G+8A8O3C8O2G+8A8O3C8O2G+8A8O3C8O2G+8A8O3C8D+8E8G8E8E3P4C+8D8F8D8D3P4 ');
  286.    play('P8F3F4F8F4C8D8O2F8P8G+8A8O3C8O2G+8A8O3C8E-4D8D-8C8O2G+8A8O3C8E-8O2G+8A8O3C8E-8O2G+8A8O3C8 ');
  287.    play('E-4D8D-8C8O2C+8D8F8A-4G8G-8F8C+8D8F8A-4G8G-8F8G+8A8O3C8E-4D8D-8C8O2G+8A8O3C8 ');
  288.    play('E-4D8D-8C8O2D+8E8G8B-4A8A-8A8C+8D8F8A-4G8G-8F8G+8A8O3C8P8F3F4F8F3C8O2F3P4 ');
  289.   end;
  290.   4 : begin
  291.    play('T130MNO3L02CGL16P16FEDO4L02CO3GO3L16P16FEDO4L02CO3GO3L16P16FEF ');
  292.    play('L02DO3L16P16O2GGGO3L02CGL32P32L16FEDO4L02CO3GO3L16P16FEDO4L02CO3G ');
  293.    play('L16P16B-AB-L01GL02G.O2L08G.L16GL04A.L08AO3FEDCL16CDEDP16O2L08AL04B ');
  294.    play('O2L08G.L16GL04A.L08AO3FEDCGP8L04D.L08P8O2G.L16GL04A.L08AO3FEDCL16CD ');
  295.    play('EDP16O2L08AL04BO3L16P16L08G.L16GO4L08C.O3L16B-L08A-.L16GL08F.L16E- ');
  296.    play('L08D.O3L16CL01GL02G.L16P16GGGO4L08CP8O3L16CCCL02C. ');
  297.   end;
  298.   5 : begin
  299.    play('L8T150MSO3DEFGAFA4G+EG+4GE-G4DEFGAFAO4DCO3AFAO4C2O3DEFGAFA4G+EG+4GE-G4 ');
  300.    play('DEFGAFAO4DO3AFAO4DO3D2ABO4C+DEC+E4FC+F4EC+E4O3ABO4C+DECE4FC+F4E2 ');
  301.    play('O3ABO4C+DEC+E4FC+F4EC+E4O3ABO4C+DECE4FC+F4E2O3DEFGAFA4G+EG+4GE-G4 ');
  302.    play('DEFGAFAO4DCO3AFAO4C2O3DEFGAFA4G+EG+4GE-G4DEFGAFAO4DO3AFAO4DO3D2 ');
  303.   end;
  304.  end;
  305.  tune_number := tune_number + 1;
  306.  if tune_number > 5 then tune_number := 0;
  307. end;
  308.